home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-motion.el.z / vm-motion.el
Encoding:
Text File  |  1998-05-21  |  16.4 KB  |  462 lines
  1. ;;; Commands to move around in a VM folder
  2. ;;; Copyright (C) 1989-1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-motion)
  19.  
  20. (defun vm-record-and-change-message-pointer (old new)
  21.   (intern (buffer-name) vm-buffers-needing-display-update)
  22.   (vm-garbage-collect-message)
  23.   (setq vm-last-message-pointer old
  24.     vm-message-pointer new
  25.     vm-need-summary-pointer-update t))
  26.  
  27. (defun vm-goto-message (n)
  28.   "Go to the message numbered N.
  29. Interactively N is the prefix argument.  If no prefix arg is provided
  30. N is prompted for in the minibuffer.
  31.  
  32. If vm-follow-summary-cursor is non-nil this command will go to
  33. the message under the cursor in the summary buffer if the summary
  34. window is selected.  This only happens if no prefix argument is
  35. given."
  36.   (interactive
  37.    (list
  38.     (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg))
  39.       ((vm-follow-summary-cursor) nil)
  40.       (t
  41.        (let ((last-command last-command)
  42.          (this-command this-command))
  43.          (vm-read-number "Go to message: "))))))
  44.   (if (null n)
  45.       ()                ; nil means work has been done already
  46.     (vm-select-folder-buffer)
  47.     (vm-check-for-killed-summary)
  48.     (vm-error-if-folder-empty)
  49.     (vm-display nil nil '(vm-goto-message) '(vm-goto-message))
  50.     (let ((cons (nthcdr (1- n) vm-message-list)))
  51.       (if (null cons)
  52.       (error "No such message."))
  53.       (if (eq vm-message-pointer cons)
  54.       (vm-preview-current-message)
  55.     (vm-record-and-change-message-pointer vm-message-pointer cons)
  56.     (vm-preview-current-message)))))
  57.  
  58. (defun vm-goto-message-last-seen ()
  59.   "Go to the message last previewed."
  60.   (interactive)
  61.   (vm-select-folder-buffer)
  62.   (vm-check-for-killed-summary)
  63.   (vm-error-if-folder-empty)
  64.   (vm-display nil nil '(vm-goto-message-last-seen)
  65.           '(vm-goto-message-last-seen))
  66.   (if vm-last-message-pointer
  67.       (progn
  68.     (vm-record-and-change-message-pointer vm-message-pointer
  69.                           vm-last-message-pointer)
  70.     (vm-preview-current-message))))
  71.  
  72. (defun vm-goto-parent-message ()
  73.   "Go to the parent of the current message."
  74.   (interactive)
  75.   (vm-follow-summary-cursor)
  76.   (vm-select-folder-buffer)
  77.   (vm-check-for-killed-summary)
  78.   (vm-error-if-folder-empty)
  79.   (vm-build-threads-if-unbuilt)
  80.   (vm-display nil nil '(vm-goto-parent-message)
  81.           '(vm-goto-parent-message))
  82.   (let ((list (vm-th-thread-list (car vm-message-pointer)))
  83.     message)
  84.     (if (null (cdr list))
  85.     (message "Message has no parent.")
  86.       (while (cdr (cdr list))
  87.     (setq list (cdr list)))
  88.       (setq message (car (get (car list) 'messages)))
  89.       (if (null message)
  90.       (message "Parent message is not in this folder.")
  91.     (vm-record-and-change-message-pointer vm-message-pointer
  92.                           (memq message vm-message-list))
  93.     (vm-preview-current-message)))))
  94.  
  95. (defun vm-check-count (count)
  96.   (if (>= count 0)
  97.       (if (< (length vm-message-pointer) count)
  98.       (signal 'end-of-folder nil))
  99.     (if (< (1+ (- (length vm-message-list) (length vm-message-pointer)))
  100.        (vm-abs count))
  101.     (signal 'beginning-of-folder nil))))
  102.  
  103. (defun vm-move-message-pointer (direction)
  104.   (let ((mp vm-message-pointer))
  105.     (if (eq direction 'forward)
  106.     (progn
  107.       (setq mp (cdr mp))
  108.       (if (null mp)
  109.           (if vm-circular-folders
  110.           (setq mp vm-message-list)
  111.         (signal 'end-of-folder nil))))
  112.       (setq mp (vm-reverse-link-of (car mp)))
  113.       (if (null mp)
  114.       (if vm-circular-folders
  115.           (setq mp (vm-last vm-message-list))
  116.         (signal 'beginning-of-folder nil))))
  117.     (setq vm-message-pointer mp)))
  118.  
  119. (defun vm-should-skip-message (mp &optional skip-dogmatically)
  120.   (if skip-dogmatically
  121.       (or (and vm-skip-deleted-messages
  122.            (vm-deleted-flag (car mp)))
  123.       (and vm-skip-read-messages
  124.            (or (vm-deleted-flag (car mp))
  125.            (not (or (vm-new-flag (car mp))
  126.                 (vm-unread-flag (car mp))))))
  127.       (and (eq last-command 'vm-next-command-uses-marks)
  128.            (null (vm-mark-of (car mp)))))
  129.     (or (and (eq vm-skip-deleted-messages t)
  130.          (vm-deleted-flag (car mp)))
  131.     (and (eq vm-skip-read-messages t)
  132.          (or (vm-deleted-flag (car mp))
  133.          (not (or (vm-new-flag (car mp))
  134.               (vm-unread-flag (car mp))))))
  135.     (and (eq last-command 'vm-next-command-uses-marks)
  136.          (null (vm-mark-of (car mp)))))))
  137.  
  138. (defun vm-next-message (&optional count retry signal-errors)
  139.   "Go forward one message and preview it.
  140. With prefix arg (optional first argument) COUNT, go forward COUNT
  141. messages.  A negative COUNT means go backward.  If the absolute
  142. value of COUNT is greater than 1, then the values of the variables
  143. vm-skip-deleted-messages and vm-skip-read-messages are ignored.
  144.  
  145. When invoked on marked messages (via vm-next-command-uses-marks)
  146. this command 'sees' marked messages as it moves."
  147.   ;; second arg RETRY non-nil means retry a failed move, giving
  148.   ;; not nil-or-t values of the vm-skip variables a chance to
  149.   ;; work.
  150.   ;;
  151.   ;; third arg SIGNAL-ERRORS non-nil means that if after
  152.   ;; everything we still have bashed into the end or beginning of
  153.   ;; folder before completing the move, signal
  154.   ;; beginning-of-folder or end-of-folder.  Otherwise no error
  155.   ;; will be signaled.
  156.   ;;
  157.   ;; Note that interactively all args are 1, so error signaling
  158.   ;; and retries apply to all interactive moves.
  159.   (interactive "p\np\np")
  160.   (if (interactive-p)
  161.       (vm-follow-summary-cursor))
  162.   (vm-select-folder-buffer)
  163.   (vm-check-for-killed-summary)
  164.   ;; include other commands that call vm-next-message so that the
  165.   ;; correct window configuration is applied for these particular
  166.   ;; non-interactive calls.
  167.   (vm-display nil nil '(vm-next-message
  168.             vm-delete-message
  169.             vm-undelete-message
  170.             vm-scroll-forward)
  171.           (list this-command))
  172.   (and signal-errors (vm-error-if-folder-empty))
  173.   (or count (setq count 1))
  174.   (let ((oldmp vm-message-pointer)
  175.     (use-marks (eq last-command 'vm-next-command-uses-marks))
  176.     (error)
  177.     (direction (if (> count 0) 'forward 'backward))
  178.     (count (vm-abs count)))
  179.     (cond
  180.      ((null vm-message-pointer)
  181.       (setq vm-message-pointer vm-message-list))
  182.      ((/= count 1)
  183.       (condition-case ()
  184.       (let ((oldmp oldmp))
  185.         (while (not (zerop count))
  186.           (vm-move-message-pointer direction)
  187.           (if (and use-marks (null (vm-mark-of (car vm-message-pointer))))
  188.           (progn
  189.             (while (and (not (eq vm-message-pointer oldmp))
  190.                 (null (vm-mark-of (car vm-message-pointer))))
  191.               (vm-move-message-pointer direction))
  192.             (if (eq vm-message-pointer oldmp)
  193.             ;; terminate the loop
  194.             (setq count 1)
  195.               ;; reset for next pass
  196.               (setq oldmp vm-message-pointer))))
  197.           (vm-decrement count)))
  198.     (beginning-of-folder (setq error 'beginning-of-folder))
  199.     (end-of-folder (setq error 'end-of-folder))))
  200.      (t
  201.       (condition-case ()
  202.       (progn
  203.         (vm-move-message-pointer direction)
  204.         (while (and (not (eq oldmp vm-message-pointer))
  205.             (vm-should-skip-message vm-message-pointer t))
  206.           (vm-move-message-pointer direction))
  207.         ;; Retry the move if we've gone a complete circle and
  208.         ;; retries are allowed and there are other messages
  209.         ;; besides this one.
  210.         (and (eq vm-message-pointer oldmp) retry (cdr vm-message-list)
  211.          (progn
  212.            (vm-move-message-pointer direction)
  213.            (while (and (not (eq oldmp vm-message-pointer))
  214.                    (vm-should-skip-message vm-message-pointer))
  215.              (vm-move-message-pointer direction)))))
  216.     (beginning-of-folder
  217.      ;; we bumped into the beginning of the folder without finding
  218.      ;; a suitable stopping point; retry the move if we're allowed.
  219.      (setq vm-message-pointer oldmp)
  220.      ;; if the retry fails, we make sure the message pointer
  221.      ;; is restored to its old value.
  222.      (if retry
  223.          (setq vm-message-pointer
  224.            (condition-case ()
  225.                (let ((vm-message-pointer vm-message-pointer))
  226.              (vm-move-message-pointer direction)
  227.              (while (vm-should-skip-message vm-message-pointer)
  228.                (vm-move-message-pointer direction))
  229.              vm-message-pointer )
  230.              (beginning-of-folder
  231.               (setq error 'beginning-of-folder)
  232.               oldmp )))
  233.        (setq error 'beginning-of-folder)))
  234.     (end-of-folder
  235.      ;; we bumped into the end of the folder without finding
  236.      ;; a suitable stopping point; retry the move if we're allowed.
  237.      (setq vm-message-pointer oldmp)
  238.      ;; if the retry fails, we make sure the message pointer
  239.      ;; is restored to its old value.
  240.      (if retry
  241.          (setq vm-message-pointer
  242.            (condition-case ()
  243.                (let ((vm-message-pointer vm-message-pointer))
  244.              (vm-move-message-pointer direction)
  245.              (while (vm-should-skip-message vm-message-pointer)
  246.                (vm-move-message-pointer direction))
  247.              vm-message-pointer )
  248.              (end-of-folder
  249.               (setq error 'end-of-folder)
  250.               oldmp )))
  251.        (setq error 'end-of-folder))))))
  252.     (if (not (eq vm-message-pointer oldmp))
  253.     (progn
  254.       (vm-record-and-change-message-pointer oldmp vm-message-pointer)
  255.       (vm-preview-current-message)))
  256.     (and error signal-errors
  257.      (signal error nil))))
  258.  
  259. (defun vm-previous-message (&optional count retry signal-errors)
  260.   "Go back one message and preview it.
  261. With prefix arg COUNT, go backward COUNT messages.  A negative COUNT
  262. means go forward.  If the absolute value of COUNT > 1 the values of the
  263. variables vm-skip-deleted-messages and vm-skip-read-messages are
  264. ignored."
  265.   (interactive "p\np\np")
  266.   (or count (setq count 1))
  267.   (if (interactive-p)
  268.       (vm-follow-summary-cursor))
  269.   (vm-select-folder-buffer)
  270.   (vm-display nil nil '(vm-previous-message) '(vm-previous-message))
  271.   (vm-next-message (- count) retry signal-errors))
  272.  
  273. (defun vm-next-message-no-skip (&optional count)
  274.   "Like vm-next-message but will not skip deleted or read messages."
  275.   (interactive "p")
  276.   (if (interactive-p)
  277.       (vm-follow-summary-cursor))
  278.   (vm-select-folder-buffer)
  279.   (vm-display nil nil '(vm-next-message-no-skip)
  280.           '(vm-next-message-no-skip))
  281.   (let ((vm-skip-deleted-messages nil)
  282.     (vm-skip-read-messages nil))
  283.     (vm-next-message count nil t)))
  284. ;; backward compatibility
  285. (fset 'vm-Next-message 'vm-next-message-no-skip)
  286.  
  287. (defun vm-previous-message-no-skip (&optional count)
  288.   "Like vm-previous-message but will not skip deleted or read messages."
  289.   (interactive "p")
  290.   (if (interactive-p)
  291.       (vm-follow-summary-cursor))
  292.   (vm-select-folder-buffer)
  293.   (vm-display nil nil '(vm-previous-message-no-skip)
  294.           '(vm-previous-message-no-skip))
  295.   (let ((vm-skip-deleted-messages nil)
  296.     (vm-skip-read-messages nil))
  297.     (vm-previous-message count)))
  298. ;; backward compatibility
  299. (fset 'vm-Previous-message 'vm-previous-message-no-skip)
  300.  
  301. (defun vm-next-unread-message ()
  302.   "Move forward to the nearest new or unread message, if there is one."
  303.   (interactive)
  304.   (if (interactive-p)
  305.       (vm-follow-summary-cursor))
  306.   (vm-select-folder-buffer)
  307.   (vm-check-for-killed-summary)
  308.   (vm-display nil nil '(vm-next-unread-message) '(vm-next-unread-message))
  309.   (condition-case ()
  310.       (let ((vm-skip-read-messages t)
  311.         (oldmp vm-message-pointer))
  312.     (vm-next-message 1 nil t)
  313.     ;; in case vm-circular-folders is non-nil
  314.     (and (eq vm-message-pointer oldmp) (signal 'end-of-folder nil)))
  315.     (end-of-folder (message "No next unread message"))))
  316.  
  317. (defun vm-previous-unread-message ()
  318.   "Move backward to the nearest new or unread message, if there is one."
  319.   (interactive)
  320.   (if (interactive-p)
  321.       (vm-follow-summary-cursor))
  322.   (vm-select-folder-buffer)
  323.   (vm-check-for-killed-summary)
  324.   (vm-display nil nil '(vm-previous-unread-message)
  325.           '(vm-previous-unread-message))
  326.   (condition-case ()
  327.       (let ((vm-skip-read-messages t)
  328.         (oldmp vm-message-pointer))
  329.     (vm-previous-message)
  330.     ;; in case vm-circular-folders is non-nil
  331.     (and (eq vm-message-pointer oldmp) (signal 'beginning-of-folder nil)))
  332.     (beginning-of-folder (message "No previous unread message"))))
  333.  
  334. (defun vm-next-message-same-subject ()
  335.   "Move forward to the nearest message with the same subject.
  336. vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply
  337. to the subject comparisons."
  338.   (interactive)
  339.   (if (interactive-p)
  340.       (vm-follow-summary-cursor))
  341.   (vm-select-folder-buffer)
  342.   (vm-check-for-killed-summary)
  343.   (vm-display nil nil '(vm-next-message-same-subject)
  344.           '(vm-next-message-same-subject))
  345.   (let ((oldmp vm-message-pointer)
  346.     (done nil)
  347.     (subject (vm-so-sortable-subject (car vm-message-pointer))))
  348.     (condition-case ()
  349.     (progn
  350.       (while (not done)
  351.         (vm-move-message-pointer 'forward)
  352.         (if (eq oldmp vm-message-pointer)
  353.         (signal 'end-of-folder nil))
  354.         (if (equal subject
  355.                (vm-so-sortable-subject (car vm-message-pointer)))
  356.         (setq done t)))
  357.       (vm-record-and-change-message-pointer oldmp vm-message-pointer)
  358.       (vm-preview-current-message))
  359.       (end-of-folder
  360.        (setq vm-message-pointer oldmp)
  361.        (message "No next message with the same subject")))))
  362.  
  363. (defun vm-previous-message-same-subject ()
  364.   "Move backward to the nearest message with the same subject.
  365. vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply
  366. to the subject comparisons."
  367.   (interactive)
  368.   (if (interactive-p)
  369.       (vm-follow-summary-cursor))
  370.   (vm-select-folder-buffer)
  371.   (vm-check-for-killed-summary)
  372.   (vm-display nil nil '(vm-previous-message-same-subject)
  373.           '(vm-previous-message-same-subject))
  374.   (let ((oldmp vm-message-pointer)
  375.     (done nil)
  376.     (subject (vm-so-sortable-subject (car vm-message-pointer))))
  377.     (condition-case ()
  378.     (progn
  379.       (while (not done)
  380.         (vm-move-message-pointer 'backward)
  381.         (if (eq oldmp vm-message-pointer)
  382.         (signal 'beginning-of-folder nil))
  383.         (if (equal subject
  384.                (vm-so-sortable-subject (car vm-message-pointer)))
  385.         (setq done t)))
  386.       (vm-record-and-change-message-pointer oldmp vm-message-pointer)
  387.       (vm-preview-current-message))
  388.       (beginning-of-folder
  389.        (setq vm-message-pointer oldmp)
  390.        (message "No previous message with the same subject")))))
  391.  
  392. (defun vm-find-first-unread-message (new)
  393.   (let (mp unread-mp)
  394.     (setq mp vm-message-list)
  395.     (if new
  396.     (while mp
  397.       (if (and (vm-new-flag (car mp)) (not (vm-deleted-flag (car mp))))
  398.           (setq unread-mp mp mp nil)
  399.         (setq mp (cdr mp))))
  400.       (while mp
  401.     (if (and (or (vm-new-flag (car mp)) (vm-unread-flag (car mp)))
  402.          (not (vm-deleted-flag (car mp))))
  403.         (setq unread-mp mp mp nil)
  404.       (setq mp (cdr mp)))))
  405.     unread-mp ))
  406.  
  407. (defun vm-thoughtfully-select-message ()
  408.   (let ((new (and vm-jump-to-new-messages (vm-find-first-unread-message t)))
  409.     (unread (and vm-jump-to-unread-messages
  410.              (vm-find-first-unread-message nil)))
  411.     fix mp)
  412.     (if (null vm-message-pointer)
  413.     (setq fix (vm-last vm-message-list)))
  414.     (setq mp (or new unread fix))
  415.     (if (and mp (not (eq mp vm-message-pointer)))
  416.     (progn
  417.       (vm-record-and-change-message-pointer vm-message-pointer mp)
  418.       mp )
  419.       nil )))
  420.  
  421. (defun vm-follow-summary-cursor ()
  422.   (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode)
  423.        (let ((point (point))
  424.          message-pointer message-list mp)
  425.      (save-excursion
  426.        (set-buffer vm-mail-buffer)
  427.        (setq message-pointer vm-message-pointer
  428.          message-list vm-message-list))
  429.      (cond ((or (null message-pointer)
  430.             (and (>= point (vm-su-start-of (car message-pointer)))
  431.              (< point (vm-su-end-of (car message-pointer)))))
  432.         nil )
  433.            ;; the position at eob belongs to the last message
  434.            ((and (eobp) (= (vm-su-end-of (car message-pointer)) point))
  435.         nil )
  436.            ;; make the position at eob belong to the last message
  437.            ((eobp)
  438.         (setq mp (vm-last message-pointer))
  439.         (save-excursion
  440.           (set-buffer vm-mail-buffer)
  441.           (vm-record-and-change-message-pointer vm-message-pointer mp)
  442.           (vm-preview-current-message)
  443.           ;; return non-nil so the caller will know that
  444.           ;; a new message was selected.
  445.           t ))
  446.            (t 
  447.         (if (< point (vm-su-start-of (car message-pointer)))
  448.             (setq mp message-list)
  449.           (setq mp (cdr message-pointer) message-pointer nil))
  450.         (while (and (not (eq mp message-pointer))
  451.                 (>= point (vm-su-end-of (car mp))))
  452.           (setq mp (cdr mp)))
  453.         (if (not (eq mp message-pointer))
  454.             (save-excursion
  455.               (set-buffer vm-mail-buffer)
  456.               (vm-record-and-change-message-pointer
  457.                vm-message-pointer mp)
  458.               (vm-preview-current-message)
  459.               ;; return non-nil so the caller will know that
  460.               ;; a new message was selected.
  461.               t )))))))
  462.